home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / sml_nj / 93src.lha / src / modules / extern.sml < prev    next >
Encoding:
Text File  |  1993-01-27  |  4.7 KB  |  135 lines
  1. (* Copyright 1992 by AT&T Bell Laboratories *)
  2.  
  3. (***************************************************************************
  4.  
  5.   EXTERN.SML: externalize sharings on a structure already defined in a 
  6.   signature. It is used by instantiate.sml when part of the signature is
  7.   already instantiated (parent for an argument signature - argument for a
  8.   functor body signature).
  9.  
  10.  ***************************************************************************)
  11.  
  12. signature EXTERN = sig
  13.   val name_A: Symbol.symbol
  14.   val name_P: Symbol.symbol
  15.   val name_X: Symbol.symbol
  16.   val name_O: Symbol.symbol
  17.   val name_B: Symbol.symbol
  18.   val hidden: Symbol.symbol -> bool
  19.   val externalize_sharing: 
  20.     Symbol.symbol -> Modules.Structure
  21.     -> Modules.Signature -> Modules.Signature
  22.   val update_structure:
  23.     Symbol.symbol -> Modules.Structure -> Modules.Structure -> unit
  24.   val make_argument :
  25.         {parent:Modules.Structure, parameter:Modules.Structure}
  26.          -> Modules.Structure
  27. end;
  28.  
  29. structure Extern: EXTERN = struct
  30. open Symbol Access Modules ModuleUtil ErrorMsg TypesUtil;
  31.  
  32. val name_A = strSymbol "<Argument>"
  33. val name_P = strSymbol "<Parent>"
  34. val name_X = strSymbol "<Parameter>"
  35. val name_O = strSymbol "<open>"
  36. val name_B = strSymbol "<body>"
  37.  
  38. fun hidden s = (s=name_A) orelse (s=name_P) orelse (s=name_O)
  39.  
  40. fun externalize_sharing_str name str {internal,external} =
  41.   fold 
  42.     (fn ([],res) => res (* nul paths shouldn't exist anyway *)
  43.       | (path as (sym::end_path),{internal,external})=>
  44.        if sym = name then 
  45.          let val STRvar{binding=new_ext,...} = lookBindingSTR (str,end_path) in
  46.          case external
  47.          of NONE => {internal=internal,external=SOME new_ext}
  48.           | SOME old_ext => 
  49.               if eqOrigin (new_ext,old_ext) then 
  50.                 {internal=internal,external=external}
  51.               else impossible "Extern: extern_sharing_str"
  52.          end
  53.        else
  54.          {internal=path::internal,external=external})
  55.   internal {internal=[],external=external}
  56. ;         
  57.  
  58. fun externalize_sharing_tyc name str {internal,external} =
  59.   fold 
  60.     (fn ([],res) => res (* nul paths shouldn't exist anyway *)
  61.       | (path as (sym::end_path),{internal,external})=>
  62.        if sym = name then 
  63.          let val new_ext =  lookBindingTYC (str,end_path) in
  64.          case external
  65.          of NONE => {internal=internal,external=SOME new_ext}
  66.           | SOME old_ext => 
  67.               if equalTycon (new_ext,old_ext) then 
  68.                 {internal=internal,external=external}
  69.               else impossible "Extern: extern_sharing_tyc"
  70.          end
  71.        else
  72.          {internal=path::internal,external=external})
  73.   internal {internal=[],external=external}
  74. ;         
  75.  
  76. fun externalize_sharing name parent
  77.     (SIG{stamp,symbols,path,env, 
  78.          kind=ref (TOP{strcount,fctcount,typecount,slotcount,
  79.                        sConstraints,tConstraints})}) =
  80.       SIG{
  81.         stamp=stamp,env=env,symbols=symbols,path=path,
  82.         kind=ref (TOP{strcount=strcount,fctcount=fctcount,
  83.                       typecount=typecount,slotcount=slotcount,
  84.                       sConstraints= 
  85.                         map (externalize_sharing_str name parent) sConstraints,
  86.                       tConstraints=
  87.                         map (externalize_sharing_tyc name parent) tConstraints
  88.                 })}
  89.   | externalize_sharing _ _ ERROR_SIG = ERROR_SIG
  90.   | externalize_sharing _ _ _ = impossible "Extern: externalize_sharing"
  91.  
  92.  
  93. fun update_structure name str arg =
  94.   case arg
  95.   of INSTANCE{sign as SIG{env,...},subStrs,...} => ((
  96.        case Env.look(!env,name)
  97.        of (STRbind (STRvar {binding=STR_FORMAL {pos, ...},...})) =>
  98.          Array.update(subStrs,pos,str)
  99.     | _ => impossible "Extern: update_structure 1")
  100.        handle Env.Unbound => 
  101.      if name = name_A then () else impossible "Extern: update_structure 3")
  102.    | ERROR_STR => ()
  103.    | INSTANCE{sign as ERROR_SIG,...} => ()
  104.    | _ => impossible "Extern: update_structure 2"
  105.  
  106.  
  107. fun make_argument {parent,parameter} =
  108.   let val binding_X = 
  109.         STRbind(STRvar{name=name_X,access=SLOT 1,
  110.                binding=STR_FORMAL{pos=1,spec=FULL_SIG}})
  111.       val binding_P = 
  112.         STRbind(STRvar{name=name_P,access=SLOT 0,
  113.                binding=STR_FORMAL{pos=0,spec=FULL_SIG}})
  114.       val env = 
  115.         Env.bind (name_X, binding_X,
  116.                   Env.bind (name_P, binding_P, Env.empty))
  117.   in
  118.   INSTANCE{
  119.     sign=SIG{symbols = ref [name_P,name_X],
  120.              path = NONE,
  121.              stamp = Stamps.newFree (),
  122.              env = ref env,
  123.              kind = ref (TOP{strcount=2,fctcount=0,typecount=0,slotcount=0,
  124.                              tConstraints=[],sConstraints=[]})},
  125.     subStrs = Array.arrayoflist [parent,parameter],
  126.     subFcts = Array.arrayoflist [],
  127.     types = Array.arrayoflist [],
  128.     origin = SELF(Stamps.newFree ()),
  129.     path = []}
  130.   end
  131.  
  132. end
  133.  
  134.  
  135.